home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
DEMO_VGA
/
VGADEMO3.LZH
/
PLASMA.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-06-24
|
4KB
|
145 lines
{ Turbo Pascal 4.0 source code }
{$I-}
program plasma;
uses
Crt,Dos;
const
F = 2.0; { the "roughness" of the image }
type
ColorValue = record Rvalue,Gvalue,Bvalue: byte; end;
PaletteType = array [0..255] of ColorValue;
var
ch: char;
i: integer;
p: PaletteType;
image: file;
ok: boolean;
procedure SetVGApalette(var tp: PaletteType);
var regs: Registers;
begin { procedure SetVGApalette }
with regs do
begin
AX:=$1012;
BX:=0; { first register to set }
CX:=256; { number of registers to set }
ES:=Seg(tp); DX:=Ofs(tp);
end;
Intr($10,regs);
end; { procedure SetVGApalette }
procedure PutPixel(x,y: integer; c: byte);
begin { procedure PutPixel }
mem[$A000:word(320*y+x)]:=c;
end; { procedure PutPixel }
function GetPixel(x,y: integer): byte;
begin { function GetPixel }
GetPixel:=mem[$A000:word(320*y+x)];
end; { function GetPixel }
procedure adjust(xa,ya,x,y,xb,yb: integer);
var
d: integer;
v: real;
begin { procedure adjust }
if GetPixel(x,y)<>0 then exit;
d:=Abs(xa-xb)+Abs(ya-yb);
v:=(GetPixel(xa,ya)+GetPixel(xb,yb))/2+(random-0.5)*d*F;
if v<1 then v:=1;
if v>=193 then v:=192;
PutPixel(x,y,Trunc(v));
end; { procedure adjust }
procedure subDivide(x1,y1,x2,y2: integer);
var
x,y: integer;
v: real;
begin { procedure subDivide }
if KeyPressed then exit;
if (x2-x1<2) and (y2-y1<2) then exit;
x:=(x1+x2) div 2;
y:=(y1+y2) div 2;
adjust(x1,y1,x,y1,x2,y1);
adjust(x2,y1,x2,y,x2,y2);
adjust(x1,y2,x,y2,x2,y2);
adjust(x1,y1,x1,y,x1,y2);
if GetPixel(x,y)=0 then
begin
v:=(GetPixel(x1,y1)+GetPixel(x2,y1)+GetPixel(x2,y2)+GetPixel(x1,y2))/4;
PutPixel(x,y,Trunc(v));
end;
subDivide(x1,y1,x,y);
subDivide(x,y1,x2,y);
subDivide(x,y,x2,y2);
subDivide(x1,y,x,y2);
end; { procedure subDivide }
procedure rotatePalette(var p: PaletteType; n1,n2,d: integer);
var
q: PaletteType;
begin { procedure rotatePalette }
q:=p;
for i:=n1 to n2 do
p[i]:=q[n1+(i+d) mod (n2-n1+1)];
SetVGApalette(p);
end; { procedure rotatePalette }
begin
Inline($B8/$13/0/$CD/$10); { select video mode 13h (320x200 with 256 colors) }
with p[0] do { set background palette entry to grey }
begin
Rvalue:=32;
Gvalue:=32;
Bvalue:=32;
end;
for i:=0 to 63 do { create the color wheel }
begin
with p[i+1] do begin Rvalue:=i; Gvalue:=63-i; Bvalue:=0; end;
with p[i+65] do begin Rvalue:=63-i; Gvalue:=0; Bvalue:=i; end;
with p[i+129] do begin Rvalue:=0; Gvalue:=i; Bvalue:=63-i; end;
end;
SetVGApalette(p);
Assign(image,'PLASMA.IMG');
Reset(image,1);
ok:=(ioResult=0);
if not ok or (ParamCount<>0) then { create a new image }
begin
Randomize;
PutPixel(0,0,1+Random(192));
PutPixel(319,0,1+Random(192));
PutPixel(319,199,1+Random(192));
PutPixel(0,199,1+Random(192));
subDivide(0,0,319,199);
Rewrite(image,1);
BlockWrite(image,mem[$A000:0],$FA00);
end
else { use the previous image }
BlockRead(image,mem[$A000:0],$FA00);
Close(image);
repeat
rotatePalette(p,1,192,+1);
until KeyPressed;
ch:=ReadKey; if ch=#0 then ch:=ReadKey;
TextMode(LastMode);
end.